home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / ti / pcscm3_3 / pkdisk2.arc / KLDSCOPE.S < prev    next >
Encoding:
Text File  |  1988-06-07  |  4.5 KB  |  150 lines
  1. ;;; Sample graphics routines using the %GRAPHICS primitive.
  2.  
  3. ;;; Note that %GRAPHICS may change in meaning in future versions of the system,
  4. ;;; as it has between versions 2.0 and 3.0.
  5. ;;; Using macros or define-integrables to protect your code
  6. ;;; from explicit uses of %GRAPHICS is highly recommended.
  7.  
  8. ;;; Determine what type of video adapter we have.
  9. (define video-type
  10.   (lambda ()
  11.     (if (= pcs-machine-type 1)
  12.     ;; it's TI
  13.     'ti
  14.     ;; it's IBM
  15.     (let ((mode (%graphics 5 0 0 0 0 0 0))) ;; get video mode
  16.       (case mode
  17.         (3 'cga)
  18.         ((14 16) 'ega)
  19.         (else 'cga))))))
  20.  
  21.  
  22. ;;; Initialize Graphics (sets palette registers; clears graphics planes)
  23. (define grinit
  24.   (lambda ()
  25.     (case (video-type)
  26.       (ti  (%graphics 0 0 0 0 0 0 0)        ;; clear graphics
  27.        (window-clear (make-window "" '())))
  28.       (cga (%graphics 0 4 0 0 0 0 0)        ;; 4-color graphics mode
  29.        (%graphics 2 0 0 0 0 0 0)        ;; set background to black
  30.        (%graphics 2 1 0 0 0 0 0))        ;; use black,red,green,brown
  31.       (ega (%graphics 0 16 0 0 0 0 0)        ;; 16-color graphics mode
  32.        (%graphics 2 0 0 0 0 0 0)        ;; not necessary here
  33.        (%graphics 2 1 0 0 0 0 0))
  34.       )))
  35.  
  36.  
  37. ;     Set point
  38. (define-integrable setp
  39.   (lambda (x y color) (%graphics 1 x y color 0 0 0)))
  40.  
  41. ;     Reset point (turns it off)
  42. (define-integrable resetp
  43.   (lambda (x y) (%graphics 2 x y 0 0 0 0)))
  44.  
  45. ;     Draw Line
  46. (define-integrable line
  47.   (lambda (x1 y1 x2 y2 color)
  48.     (%graphics 3 x1 y1 x2 y2 color 0)))
  49.  
  50. ;     Read Point (returns its color)
  51. (define-integrable point
  52.   (lambda (x y) (%graphics 4 x y 0 0 0 0)))
  53.  
  54. ; %graphics 5 is identical to get-video-mode
  55.  
  56. ;     Draw box
  57. (define-integrable draw-box
  58.   (lambda (x1 y1 x2 y2 color)
  59.     (%graphics 6 x1 y1 x2 y2 color 0)))
  60.  
  61. ;     Draw Filled Box
  62. (define-integrable draw-filled-box
  63.   (lambda (x1 y1 x2 y2 color)
  64.     (%graphics 7 x1 y1 x2 y2 color 0)))
  65.  
  66.  
  67. ;     Kaleidoscope Program [Translated from Basic]
  68.  
  69. ; Note: To stop this program, press the "q" key.  To start a new pattern
  70. ;    going, press any other key.
  71. (alias kldscope kald)
  72. (alias kaleidosope kald)
  73. (define kald
  74.   (lambda ()
  75.     (let* ((old-video-mode (%graphics 5 0 0 0 0 0 0))
  76.        (vmode (video-type))
  77.        (accel-range    (case vmode (ti  12) (cga   6) (ega    12)))
  78.        (accel-adj       (case vmode (ti   5) (cga   3) (ega     5)))
  79.        (usable-colors  (case vmode (ti   7) (cga   3) (ega    15)))
  80.        (wh           (case vmode (ti 360) (cga 160) (ega 320)))
  81.        (mi           (case vmode (ti 145) (cga  75) (ega 150)))
  82.        (ycenter-offset (case vmode (ti   5) (cga  25) (ega    25)))
  83.         ;; Add 5/25/25 (TI/CGA/EGA) to y-coordinates 'cause we said that the
  84.         ;; screens are only 290/150/300-pixels high when, in actuality,
  85.         ;; they're 300/200/350.
  86.        (m1 (+ mi 1))
  87.        (xv1 nil)
  88.        (xv2 nil)
  89.        (yv1 nil)
  90.        (yv2 nil)
  91.        )
  92.       (letrec
  93.         (
  94.          (quit-kald
  95.            (lambda ()
  96.          (grinit)
  97.          (%graphics 0 old-video-mode 0 0 0 0 0)
  98.          (window-set-cursor! 'console 0 0)
  99.          (gc)
  100.          *the-non-printing-object*
  101.          ))
  102.          (loop
  103.            (lambda (a n color x1 y1 x2 y2)
  104.          (cond ((positive? a)
  105.             (let ((2x1 (+ x1 x1))
  106.                   (2y1 (+ y1 y1))
  107.                   (2x2 (+ x2 x2))
  108.                   (2y2 (+ y2 y2))
  109.                   (w wh)
  110.                   (m (+ mi ycenter-offset)))
  111.             (line (+ w 2x1) (- m y1) (+ w 2x2) (- m y2) color) ; 1
  112.             (line (- w 2y1) (+ m x1) (- w 2y2) (+ m x2) color) ; 2
  113.             (line (- w 2x1) (- m y1) (- w 2x2) (- m y2) color) ; 3
  114.             (line (- w 2y1) (- m x1) (- w 2y2) (- m x2) color) ; 4
  115.             (line (- w 2x1) (+ m y1) (- w 2x2) (+ m y2) color) ; 5
  116.             (line (+ w 2y1) (- m x1) (+ w 2y2) (- m x2) color) ; 6
  117.             (line (+ w 2x1) (+ m y1) (+ w 2x2) (+ m y2) color) ; 7
  118.             (line (+ w 2y1) (+ m x1) (+ w 2y2) (+ m x2) color) ; 8
  119.             (if (positive? n)
  120.             (loop (- a 1)
  121.                   (- n 1)
  122.                   color
  123.                   (remainder (+ x1 xv1) m1)
  124.                   (remainder (+ y1 yv1) m1)
  125.                   (remainder (+ x2 xv2) m1)
  126.                   (remainder (+ y2 yv2) m1))
  127.             (restart))))
  128.          ((not (char-ready?))
  129.           (set! xv1 (- (random accel-range) accel-adj))
  130.           (set! yv1 (- (random accel-range) accel-adj))
  131.           (set! xv2 (- (random accel-range) accel-adj))
  132.           (set! yv2 (- (random accel-range) accel-adj))
  133.           (loop (random 10) n (+ (random usable-colors) 1) x1 y1 x2 y2))
  134.          ((eq? (char-upcase (read-char)) '#\Q)
  135.           (quit-kald))
  136.          (else
  137.           (restart)))))
  138.     (restart
  139.      (lambda ()
  140.        (grinit)
  141.        (randomize 0)
  142.        (loop 0 (+ 50 (random 200)) 0
  143.            (+ (random mi) 1)
  144.            (+ (random mi) 1)
  145.            (+ (random mi) 1)
  146.            (+ (random mi) 1)))))
  147.        (begin
  148.      (flush-input)
  149.      (restart))))))
  150.